Shareware Super Platinum 8/Shareware Super Platinum 8.iso/mac/WIN_VB/VBINT.ZIP;1/INTDEMO.FRM

Visual Basic Form | 1994-06-04 | 12.7 KB | 468 lines

VERSION 2.00
Begin Form IntDemo
   AutoRedraw      =   -1  'True
   Caption         =   "DOS Interrupt Test"
   ClientHeight    =   5295
   ClientLeft      =   990
   ClientTop       =   1470
   ClientWidth     =   7005
   Height          =   5700
   Icon            =   INTDEMO.FRX:0000
   Left            =   930
   LinkTopic       =   "Form1"
   ScaleHeight     =   5295
   ScaleWidth      =   7005
   Top             =   1125
   Width           =   7125
   Begin CommandButton bCmd
      Caption         =   "Dir &Listing"
      Height          =   495
      Index           =   6
      Left            =   5280
      TabIndex        =   5
      Top             =   3060
      Width           =   1545
   End
   Begin Timer Timer1
      Enabled         =   0   'False
      Interval        =   750
      Left            =   4500
      Top             =   30
   End
   Begin CommandButton bCmd
      Caption         =   "Dir &Tree"
      Height          =   495
      Index           =   4
      Left            =   5280
      TabIndex        =   4
      Top             =   2490
      Width           =   1545
   End
   Begin ListBox List1
      FontBold        =   0   'False
      FontItalic      =   0   'False
      FontName        =   "MS Sans Serif"
      FontSize        =   8.25
      FontStrikethru  =   0   'False
      FontUnderline   =   0   'False
      Height          =   4125
      Left            =   300
      TabIndex        =   9
      Top             =   960
      Visible         =   0   'False
      Width           =   4635
   End
   Begin CommandButton bCmd
      Caption         =   "&FindFirst/Next"
      Height          =   495
      Index           =   3
      Left            =   5280
      TabIndex        =   3
      Top             =   1920
      Width           =   1545
   End
   Begin TextBox Text1
      Height          =   345
      Left            =   300
      TabIndex        =   8
      Text            =   "Text1"
      Top             =   480
      Visible         =   0   'False
      Width           =   4635
   End
   Begin CommandButton bCmd
      Caption         =   "D&OS ""Stuff"""
      Height          =   495
      Index           =   2
      Left            =   5280
      TabIndex        =   0
      Top             =   210
      Width           =   1545
   End
   Begin CommandButton bCmd
      Cancel          =   -1  'True
      Caption         =   "E&xit"
      Height          =   495
      Index           =   5
      Left            =   5280
      TabIndex        =   6
      Top             =   4590
      Width           =   1545
   End
   Begin CommandButton bCmd
      Caption         =   "Get &Space"
      Height          =   495
      Index           =   1
      Left            =   5280
      TabIndex        =   1
      Top             =   780
      Width           =   1545
   End
   Begin CommandButton bCmd
      Caption         =   "Get Cur&Dirs"
      Height          =   495
      Index           =   0
      Left            =   5280
      TabIndex        =   2
      Top             =   1350
      Width           =   1545
   End
   Begin Image Image1
      Height          =   975
      Left            =   5520
      Stretch         =   -1  'True
      Top             =   3600
      Width           =   1065
   End
   Begin Label Label1
      AutoSize        =   -1  'True
      Caption         =   "Label1"
      Height          =   195
      Left            =   300
      TabIndex        =   7
      Top             =   210
      Visible         =   0   'False
      Width           =   585
   End
'---------------------------------------------------------------------------
' DOS Interrupt Demo Program, Copyright (c) 1994 Karl E. Peterson
' Redistributed by permission.
' Requires: VBInt.DLL, VBRun300.DLL
' This program may be distributed freely on the condition that it is
' distributed in full, and unmodified, and that no fee is charged for such
' distribution with the exception of reasonable media and shipping charges.
' Any or all portions of the source code may be incorporated into your own
' programs, and those programs may be distributed without payment of
' royalties on the condition that such programs differ substantially from
' this demonstration program.
' This program is distributed AS IS.  The author acknowledges absolutely
' no liability for its use or misuse.  The sole purpose of this program is to
' demonstrate some of the powerful capabilities of VBInt.DLL, written and
' copyrighted by Rick Esterling.  Calling DOS interrupts from Windows is
' fairly "non-standard" behavior.  Users of this program acknowledge that
' they are doing so at their OWN RISK.
' This demonstration program was created and distributed by:
'   Karl E. Peterson
'   Regional Transportation Council
'   1351 Officers' Row
'   Vancouver, Washington 98661
'   CompuServe: 72302,3707
' Your comments or questions are invited!
'---------------------------------------------------------------------------
Option Explicit
DefInt A-Z
Const bDirs = 0
Const bSpace = 1
Const bDOS = 2
Const bFind = 3
Const bTree = 4
Const bList = 6
Const bExit = 5
Dim DtaEstablished%
Sub bCmd_Click (Index As Integer)
  Screen.MousePointer = 11
  Cls
  Select Case Index
    Case bDirs, bSpace, bDOS, bExit
      Text1.Visible = False
      Label1.Visible = False
      List1.Visible = False
      Select Case Index
        Case bDirs: ShowCurrentDirs
        Case bSpace: ShowFreeSpace
        Case bDOS: ShowDosStuff
        Case bExit: Unload Me
      End Select
    Case bFind
      List1.Visible = False
      Text1 = "C:\*.*"
      Text1.Visible = True
      Label1 = "FileSpec to Find (press Enter for each match):"
      Label1.Visible = True
      Text1.SetFocus
      Text1.SelStart = 0
      Text1.SelLength = Len(Text1)
      Timer1.Enabled = True
      DtaEstablished = False
    Case bTree, bList
      Text1.Visible = True
      Label1.Visible = True
      List1.Visible = True
      Select Case Index
        Case bTree
          Text1 = "C:"
          Label1 = "Drive to Search (press Enter to begin scan):"
          Refresh
          ShowDirTree (Text1), List1
        Case bList
          Text1 = "C:\"
          Label1 = "Directory to Search (press Enter to begin scan):"
          Refresh
          ShowDirList (Text1), List1
      End Select
      Text1.SetFocus
      Text1.SelStart = 0
      Text1.SelLength = Len(Text1)
  End Select
  Screen.MousePointer = 0
End Sub
Sub Form_Load ()
  Dim Proceed%, m$
  Proceed = IDYES
  If WinIsNT() Then
    m$ = "Running under Windows NT!" + Chr$(13) + Chr$(10)
    m$ = m$ + "Do you wish to continue?"
    Proceed = MsgBox(m$, MB_YESNO + MB_ICONEXCLAMATION + MB_DEFBUTTON2, "Warning")
  End If
  If Proceed = IDYES Then
    DosVersion = DosGetVersion()
    Move (Screen.Width - Width) \ 2, (Screen.Height - Height) \ 2
    SetTabs List1
    Show
    bCmd_Click bDOS
  Else
    Unload Me
  End If
  Image1.Picture = Me.Icon
End Sub
Sub SetColor (Bold%)
  If Bold Then
    ForeColor = &H80000008
  Else
    ForeColor = RGB(128, 128, 128)
  End If
End Sub
Sub SetTabs (Lst As ListBox)
  ReDim Tabs(0 To 4) As Integer
  Dim Rtn%
  Tabs(0) = 60
  Tabs(1) = 100
  Tabs(2) = 140
  Tabs(3) = 180
  Tabs(4) = 220
  Rtn = SendMessage(Lst.hWnd, LB_SETTABSTOPS, 5, Tabs(0))
End Sub
Sub ShowCurrentDirs ()
  Dim i%, CurrDir$
  Cls
  For i = 1 To 26
    ForeColor = RGB(128, 0, 0)
    If DrvRemovable(Chr$(i + 64)) Then
      Print "* ";
    ElseIf DrvCDRom(Chr$(i + 64)) Then
      Print "[CD]";
    End If
    If DrvGetDir(Chr$(i + 64), CurrDir$) Then
      ForeColor = RGB(0, 0, 128)
      Print "{" + DrvGetVolume$(Chr$(i + 64)) + "}  ";
      If DrvRemote(Chr$(i + 64)) Then
        ForeColor = RGB(0, 128, 0)
      Else
        ForeColor = RGB(0, 0, 0)
      End If
      Print Chr$(i + 64) + ":" + CurrDir$
    Else
      ForeColor = RGB(128, 128, 128)
      Print Chr$(i + 64) + ": -->" + CurrDir$
    End If
  Next i
  ForeColor = RGB(128, 0, 0)
  Print "* -- Removable Media   ";
  ForeColor = RGB(0, 0, 128)
  Print "{Volume Label}   ";
  ForeColor = RGB(0, 128, 0)
  Print "Remote Drive"
  ForeColor = RGB(0, 0, 0)
End Sub
Sub ShowDirList (DirSpec$, Lst As ListBox)
  Dim Files() As FileDataType
  Dim i%
  Screen.MousePointer = 11
    Lst.Clear
    Lst.Refresh
    If Right$(DirSpec$, 1) <> "\" Then
      DirSpec$ = DirSpec$ + "\*.*"
    Else
      DirSpec$ = DirSpec$ + "*.*"
    End If
    i = FillDirArray(DirSpec$, Files(), attrAllNorm, False, False)
    If i Then
      Lst.AddItem DosErrorMsg$(i)
    Else
      For i = LBound(Files) To UBound(Files)
        Lst.AddItem FmtDirEntry$(Files(i))
      Next i
    End If
  Screen.MousePointer = 0
End Sub
Sub ShowDirTree (Drive$, Lst As ListBox)
  Dim Dirs() As String
  Dim i%
  Screen.MousePointer = 11
    Lst.Clear
    Lst.Refresh
    FillDirTreeArray Dirs(), UCase$(Left$(Drive$, 1)) + ":\", 0
    For i = LBound(Dirs) To UBound(Dirs)
      Lst.AddItem Dirs(i)
    Next i
  Screen.MousePointer = 0
End Sub
Sub ShowDosStuff ()
  Cls
  Print "DOS Version " & Format$(DosVersion / 100, "#0.00")
  If DosAnsiLoaded() Then
    SetColor 1
    Print "Ansi Loaded"
  Else
    SetColor 0
    Print "Ansi NOT Loaded"
  End If
  If DosAppendLoaded() Then
    SetColor 1
    Print "Append Loaded"
  Else
    SetColor 0
    Print "Append NOT Loaded"
  End If
  If DosAssignLoaded() Then
    SetColor 1
    Print "Assign Loaded"
  Else
    SetColor 0
    Print "Assign NOT Loaded"
  End If
  If DosDblSpaceLoaded() Then
    SetColor 1
    Print "DblSpace Loaded"
  Else
    SetColor 0
    Print "DblSpace NOT Loaded"
  End If
  If DosDosKeyLoaded() Then
    SetColor 1
    Print "DosKey Loaded"
  Else
    SetColor 0
    Print "DosKey NOT Loaded"
  End If
  If DosHimemLoaded() Then
    SetColor 1
    Print "HiMem Loaded"
  Else
    SetColor 0
    Print "HiMem NOT Loaded"
  End If
  If DosGraftablLoaded() Then
    SetColor 1
    Print "GrafTabl Loaded"
  Else
    SetColor 0
    Print "GrafTabl NOT Loaded"
  End If
  If DosNetworkLoaded() Then
    SetColor 1
    Print "Network Loaded"
  Else
    SetColor 0
    Print "Network NOT Loaded"
  End If
  If DosNlsfuncLoaded() Then
    SetColor 1
    Print "NlsFunc Loaded"
  Else
    SetColor 0
    Print "NlsFunc NOT Loaded"
  End If
  If DosPrintLoaded() Then
    SetColor 1
    Print "Print Loaded"
  Else
    SetColor 0
    Print "Print NOT Loaded"
  End If
  If DosShareLoaded() Then
    SetColor 1
    Print "Share Loaded"
  Else
    SetColor 0
    Print "Share NOT Loaded"
  End If
  SetColor 1
End Sub
Sub ShowFileFound (Txt As TextBox, First%)
  Static DTA As DTAType
  Dim File As FileDataType
  Dim ErrorCode%, Rtn%
  If First Then
    Rtn = FileFindFirst((Txt), DTA, attrAllFile, ErrorCode)
  Else
    Rtn = FileFindNext(DTA, attrAllFile, ErrorCode)
  End If
  Cls
  CurrentY = Txt.Top + Txt.Height * 1.25
  CurrentX = Txt.Left
  If ErrorCode Then
    Print DosErrorMsg$(ErrorCode)
    DtaEstablished = False
  Else
    FileGetData DTA, File
    Print File.FileName
    CurrentX = Txt.Left
    Print Format$(File.Size, "#,##0"); " bytes"
    CurrentX = Txt.Left
    Print Format$(File.sDate, "long date")
    CurrentX = Txt.Left
    Print Format$(File.sDate, "long time")
    DtaEstablished = True
  End If
  Txt.SelStart = 0
  Txt.SelLength = Len(Txt)
End Sub
Sub ShowFreeSpace ()
  Dim i%, d$, sn$
  Dim disk As DiskFreeSpaceType
  Cls
  For i = 1 To 26
    d$ = Chr$(i + 64) + ":  "
    DrvFreeSpace d$, disk
    If disk.totalBytes Then
      Print d$;
      If DrvCDRom(Chr$(i + 64)) Then
        Print "[CD-ROM]  0 of ";
      Else
        Print Format$(disk.availableBytes, "#,##0");
        Print " of ";
      End If
      Print Format$(disk.totalBytes, "#,##0"); " free  ";
      If DrvGetSerNum(d$, sn$) Then
        Print "S/N:"; sn$
      Else
        Print
      End If
    End If
  Next i
End Sub
Sub Text1_Change ()
  Timer1.Enabled = False
  DtaEstablished = False
End Sub
Sub Text1_KeyPress (KeyAscii As Integer)
  If KeyAscii = 13 Then 'Enter
    KeyAscii = 0
    If InStr(Label1, "FileSpec") Then
      Dim First%
      If Not DtaEstablished Then First = True
      ShowFileFound Text1, First
    ElseIf InStr(Label1, "Drive") Then
      ShowDirTree (Text1), List1
    Else
      ShowDirList (Text1), List1
    End If
  End If
End Sub
Sub Timer1_Timer ()
  If ActiveControl Is Text1 Then
    SendKeys "{Enter}"
  End If
End Sub